home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / tspa3355.zip / TSUNTG.TST < prev    next >
Text File  |  1993-07-26  |  9KB  |  351 lines
  1. {$M 16384,0,655360}
  2.  
  3. (* This is a test program for the TSUNTG.TPU unit
  4.    Updated 26-Nov-89, 6-Dec-89, 14-Jun-90, 22-Jul-90, 1-Aug-90,
  5.            8-Aug-90, 27-Oct-91, 13-Jun-92, 19-Oct-92, 8-Nov-92,
  6.            26-Jul-93  *)
  7.  
  8. uses Dos,
  9.      TSUNTB,  (* to have access to number base conversion *)
  10.      TSUNTH,  (* to have access to keyboad type *)
  11.      TSUNTG;
  12.  
  13. procedure LOGO;
  14. begin
  15.   writeln;
  16.   writeln ('TSUNTG unit test by Prof. Timo Salmi');
  17.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  18. {$IFDEF VER40}
  19.   writeln ('TP version 4.0');
  20. {$ENDIF}
  21. {$IFDEF VER50}
  22.   writeln ('TP version 5.0');
  23. {$ENDIF}
  24. {$IFDEF VER55}
  25.   writeln ('TP version 5.5');
  26. {$ENDIF}
  27. {$IFDEF VER60}
  28.   writeln ('TP version 6.0');
  29. {$ENDIF}
  30. {$IFDEF VER70}
  31.   writeln ('TP version 7.0');
  32. {$ENDIF}
  33.   writeln;
  34. end;
  35.  
  36. (* Number of diskette drives *)
  37. procedure TEST1;
  38. begin
  39.   writeln ('Number of diskette drives on this system is ', DRIVESFN);
  40. end; (* test1 *)
  41.  
  42. (* Number of disk devices *)
  43. procedure TEST2;
  44. begin
  45. {$IFDEF VER50}
  46.   if swap(DosVersion) < $0300 then
  47.     begin writeln ('Not MsDos 3.+'); exit; end;
  48. {$ENDIF}
  49.   writeln ('Number of disks on this system is ', DSKCNTFN);
  50. end;  (* test2 *)
  51.  
  52. (* Number of diskette drives *)
  53. procedure TEST3;
  54. begin
  55.   writeln ('The first diskette drive is ', FDRIVEFN);
  56. end; (* test3 *)
  57.  
  58. (* Is a media present in the drive *)
  59. procedure TEST4;
  60. const drive = 'B';
  61. begin
  62.   If INDRIVFN (drive) then
  63.     writeln ('Disk present in drive ', drive)
  64.   else
  65.     writeln ('Disk not present in drive ', drive);
  66. end;  (* test4 *)
  67.  
  68. (* Cursor location test *)
  69. procedure TEST5;
  70. var x , y : byte;
  71. begin
  72.   GOATXY (10, 20);
  73.   write ('▓The block is at 10,20 .');
  74.   x := WHEREXFN - 1; y := WHEREYFN;
  75.   write (' and the point at ', x:0, ',', y:0);
  76. end;  (* test5 *)
  77.  
  78. (* Reverse the colors of an area *)
  79. procedure TEST6;
  80. begin
  81.   REVAREA (2, 2, 79, 24);
  82.   GOATXY (1, 22);
  83. end;  (* test6 *)
  84.  
  85. (* Redirection of writes *)
  86. procedure TEST7;
  87. begin
  88.   writeln ('If you get runtime error 160, first test for printer readiness');
  89.   writeln ('TSUNTC has the relevant routines');
  90.   writeln;
  91.   USEPRN;
  92.   writeln ('This goes to the printer');
  93.   writeln ('As does this');
  94.   USECON;
  95.   write   ('This goes on the screen');
  96. end;  (* test7 *)
  97.  
  98. (* Test of the timed inkey function *)
  99. procedure TEST8;
  100. var key : char;
  101.     timeout : boolean;
  102. begin
  103.   repeat
  104.     key := INKEYFN (3.0, timeout);
  105.     if not timeout then write (key)
  106.       else begin writeln; writeln ('Timeout',#7); end;
  107.   until key = #27;
  108. end;  (* test8 *)
  109.  
  110. (* Test whether a media is a fixed disk *)
  111. procedure TEST10;
  112. var drive : string;
  113. begin
  114.   write ('Enter drive letter? '); readln (drive);
  115.   case Length (drive) of
  116.     0  : drive := '0';
  117.     else drive := UpCase(drive[1]);
  118.   end;
  119.   if FIXEDFN (drive[1]) then
  120.      writeln ('Media ', drive , ' is a fixed disk')
  121.    else
  122.      writeln ('Media ', drive , ' is not a fixed disk');
  123. end;  (* test10 *)
  124.  
  125. (* Detect special keys, and normal keyboard scancodes. Note that depending
  126.    on the keyboard some of the tests below can be mutually exclusive.
  127.    CTLFN excludes detecting RTCTRLFN, LFCTRLFN, and SYSRQFN. ALTFN excludes
  128.    FLATLFN. *)
  129. procedure TEST11;
  130. var ch : char;
  131. begin
  132.   writeln ('Esc to exit');
  133.   repeat
  134.     if LFSHFTFN then write ('LfShift ');
  135.     if RTSHFTFN then write ('RtShift ');
  136.     {}
  137.     if ISENHAFN then
  138.        begin
  139.          if LFCTRLFN then write ('LfCtrl ');
  140.          if RTCTRLFN then write ('RtCtrl ');
  141.        end
  142.      else
  143.        if CTRLFN then write ('Ctrl ');
  144.     {}
  145.     if ISENHAFN then
  146.        if LFALTFN  then write ('LfAlt ')
  147.          else                               (* Notice the else else trick *)
  148.       else
  149.          if ALTFN    then write ('Alt ');
  150.     {}
  151.     if RTALTFN  then write ('RtAlt ');
  152.     if SYSRQFN  then write ('SysRq ');
  153.     if KEYPREFN then
  154.       begin
  155.         ch := READKEFN;
  156.         case ch of
  157.           #0  : begin
  158.                   write (byte(ch), ' ');    (* ord(ch) is ok, too *)
  159.                   ch := READKEFN;           (* byte(ch) is an just an *)
  160.                   write (byte(ch), ' ');    (* example of typecasting *)
  161.                 end;
  162.           #27 : exit;
  163.           else write (byte(ch), ' ');
  164.         end; {case}
  165.       end; {if}
  166.   until false;
  167. end;  (* test11 *)
  168.  
  169. (* Test reading enhanced keyboard keys. Notice the trick to get the
  170.    low and the high parts of a Turbo Pascal word *)
  171. procedure TEST12;
  172. var scancode : word;
  173.     key      : array [1..2] of byte absolute scancode;
  174. begin
  175.   repeat
  176.     scancode := RDENKEFN;
  177.     {}
  178.     {... show the first part of the scancode ...}
  179.     write (key[1], ' ');
  180.     {}
  181.     {... enhanced keys have also a second part in the scancode ...}
  182.     case key[1] of
  183.       0, 224 : write (key[2], ' ');
  184.     end;
  185.   until (key[1] = 27)                 (* escape with esc *)
  186.          or (scancode = 0);           (* not an enhanced keyboard *)
  187. end;  (* test12 *)
  188.  
  189. (* Test whether ANSI.SYS or a comparable driver has been loaded *)
  190. procedure TEST13;
  191. begin
  192.   if ISANSIFN then
  193.     writeln ('ANSI.SYS or a comparable screen driver has been installed')
  194.   else
  195.     begin
  196.       writeln;
  197.       writeln ('ANSI.SYS or a comparable screen driver has not been installed');
  198.     end;
  199. end;  (* test13 *)
  200.  
  201. (* Display the ascii value and the scancode of the key pressed *)
  202. procedure TEST14;
  203. var scanCode : byte;
  204.     charCode : byte;
  205.     s        : string;
  206. begin
  207.   writeln ('Press Esc to end this folly');
  208.   writeln;
  209.   repeat
  210.     GETSCAN (scanCode, charCode);
  211.     case charCode of
  212.       0..31, 129..255 : begin
  213.                           Str(charCode, s);
  214.                           s := 'asc(' + s + ')';
  215.                         end;
  216.       else s := chr(charCode)
  217.     end; {case}
  218.     writeln (s, ' scancode = ', scancode:3);
  219.   until scancode = 1;
  220. end;  (* test14 *)
  221.  
  222. (* Display the ascii value and the scancode of the key pressed for
  223.    the enhanced keyboard with GETESCAN. To test the presence of an
  224.    enhanced keyboard use ISENHAFN from the TSUNTH unit *)
  225. procedure TEST15;
  226. var scanCode : byte;
  227.     charCode : byte;
  228.     s        : string;
  229. begin
  230.   writeln ('Press Esc to end this folly');
  231.   writeln;
  232.   repeat
  233.     GETESCAN (scanCode, charCode);
  234.     case charCode of
  235.       0..31, 129..255 : begin
  236.                           Str(charCode, s);
  237.                           s := 'asc(' + s + ')';
  238.                         end;
  239.       else s := chr(charCode)
  240.     end; {case}
  241.     writeln (s, ' scancode = ', scancode:3);
  242.   until scancode = 1;
  243. end;  (* test15 *)
  244.  
  245. (* Test the disk status *)
  246. procedure TEST16;
  247. const drive = 'A';
  248. var status : integer;
  249. begin
  250.   status := FLOPSTFN (drive);
  251.   if status = -1 then
  252.     begin
  253.       writeln ('Invalid drive, must be A or B');
  254.       exit;
  255.     end; {if}
  256.   writeln ('Disk status for ', drive, ': $', BHEXFN(status));
  257.   case status of
  258.     $00 : writeln ('Disk present');
  259.     $02 : writeln ('Address mark not found (Disk unformatted)');
  260.     $40 : writeln ('Seek failure (Disk not present?)');
  261.     $80 : writeln ('Disk timed out (Disk not present in drive)');
  262.   end;
  263. end;  (* test16 *)
  264.  
  265. (* Test whether a drive is a substituted drive *)
  266. procedure TEST17;
  267. const drive = 'R';
  268. var isubst : boolean;
  269. begin
  270.   if (100*Lo(DosVersion) + Hi(DosVersion)) < 310 then
  271.     begin
  272.       writeln ('The MsDos version must be at least 3.1');
  273.       exit;
  274.     end;
  275.   isubst := ISUBSTFN (drive);
  276.   writeln ('Drive ', drive, ' is a substituted drive is ', isubst);
  277. end;  (* test17 *)
  278.  
  279. (* What kind of a disk is in the drive *)
  280. procedure TEST18;
  281. const drive = 'B';
  282. var mediaID : byte;
  283. begin
  284.   mediaID := MEDIAFN (drive);
  285.   write ('Media currently in drive ', drive, ': is ');
  286.   case mediaID of
  287.     $00 : writeln ('Error');
  288.     $F0 : writeln ('Floppy of 1.44Mb');
  289.     $F8 : writeln ('Fixed disk');
  290.     $F9 : writeln ('Floppy of 1.2Mb');
  291.     $FA : writeln ('Floppy of 720Kb');
  292.     $FD : writeln ('Floppy of 360Kb');
  293.     $FF : writeln ('Floppy of 320Kb');
  294.     else  writeln ('something else');
  295.   end; {case}
  296. end;  (* test18 *)
  297.  
  298. (* Get the curre